home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1995 August: Tool Chest / Dev.CD Aug 95 TC / Dev.CD Aug 95 TC.toast / Tool Chest / Development Tools & Languages / Dylan Related / Mindy / Mindy 1.2 - portable sources / libraries / dylan / debug.dylan < prev    next >
Encoding:
Text File  |  1995-03-15  |  10.4 KB  |  351 lines  |  [TEXT/ttxt]
  1. module: dylan
  2. author: William Lott (wlott@cs.cmu.edu)
  3. rcs-header: $Header: debug.dylan,v 1.11 94/11/29 06:39:11 wlott Exp $
  4.  
  5. //======================================================================
  6. //
  7. // Copyright (c) 1994  Carnegie Mellon University
  8. // All rights reserved.
  9. // 
  10. // Use and copying of this software and preparation of derivative
  11. // works based on this software are permitted, including commercial
  12. // use, provided that the following conditions are observed:
  13. // 
  14. // 1. This copyright notice must be retained in full on any copies
  15. //    and on appropriate parts of any derivative works.
  16. // 2. Documentation (paper or online) accompanying any system that
  17. //    incorporates this software, or any part of it, must acknowledge
  18. //    the contribution of the Gwydion Project at Carnegie Mellon
  19. //    University.
  20. // 
  21. // This software is made available "as is".  Neither the authors nor
  22. // Carnegie Mellon University make any warranty about the software,
  23. // its performance, or its conformity to any specification.
  24. // 
  25. // Bug reports, questions, comments, and suggestions should be sent by
  26. // E-mail to the Internet address "gwydion-bugs@cs.cmu.edu".
  27. //
  28. //======================================================================
  29. //
  30. // This file contains the support routines used by the debugger.
  31. //
  32.  
  33. define variable *debug-output* = #f;
  34.  
  35. define method report-problem (problem)
  36.   block ()
  37.     report-condition(problem, *debug-output*);
  38.   exception <error>
  39.     *format-function*(*debug-output*,
  40.             "\nproblem reporting problem... giving up");
  41.   end block;
  42. end method report-problem;
  43.  
  44.  
  45. define constant debug-variables = make(<stretchy-vector>);
  46.  
  47.  
  48. define method debugger-flush ()
  49.   debug-variables.size := 0;
  50.   puts("Flushed all debugger variables.\n");
  51.   values();
  52. end method debugger-flush;
  53.  
  54.  
  55. define method eval-debugger-expr (expr, num-debug-vars)
  56.   select (head(expr))
  57.     debug-var: =>
  58.       let var = tail(expr);
  59.       block ()
  60.     if (var < 0)
  61.       debug-variables[num-debug-vars + var];
  62.     else
  63.       debug-variables[var];
  64.     end if;
  65.       exception <error>
  66.     error("No debug variable $%=", var);
  67.       end block;
  68.     literal: => tail(expr);
  69.     funcall: =>
  70.       apply(method (func, #rest args) apply(func, args) end,
  71.         map(rcurry(eval-debugger-expr, num-debug-vars), tail(expr)));
  72.   end select;
  73. end method eval-debugger-expr;
  74.  
  75.  
  76. define method debugger-eval (expr)
  77.   block ()
  78.     block ()
  79.       let (#rest results) = eval-debugger-expr(expr, debug-variables.size);
  80.       values(#t, results);
  81.     exception (problem :: <error>)
  82.       *format-function*(*debug-output*, "invocation failed:\n  ");
  83.       report-problem(problem);
  84.       *format-function*(*debug-output*, "\n");
  85.       *force-output-function*(*debug-output*);
  86.       #f;
  87.     end block;
  88.   exception (<error>)
  89.     puts("Could not recover from earlier error.\n");
  90.     #f;
  91.   end block;
  92. end method debugger-eval;
  93.  
  94.  
  95. define method eval-and-print (expr, num-debug-vars)
  96.   let (#rest results) = eval-debugger-expr(expr, num-debug-vars);
  97.   if (empty?(results))
  98.     *format-function*(*debug-output*, "[0 values returned]");
  99.   else
  100.     for (first = #t then #f,
  101.      result in results)
  102.       unless (first)
  103.     *format-function*(*debug-output*, ", ");
  104.       end;
  105.       *format-function*(*debug-output*, "$%==%=",
  106.             debug-variables.size, result);
  107.       add!(debug-variables, result);
  108.     end for;
  109.   end if;
  110.   *format-function*(*debug-output*, "\n");
  111.   *force-output-function*(*debug-output*);
  112. end method eval-and-print;
  113.  
  114.  
  115. define method debugger-call (exprs)
  116.   let num-debug-vars = debug-variables.size;
  117.   block ()
  118.     for (expr in exprs)
  119.       eval-and-print(expr, num-debug-vars);
  120.     end for;
  121.   exception (<abort>, init-arguments: list(description: "Blow off call"))
  122.     #f;
  123.   end block;
  124. end method debugger-call;
  125.  
  126.  
  127. define method debugger-print (exprs)
  128.   block ()
  129.     let num-debug-vars = debug-variables.size;
  130.     for (expr in exprs)
  131.       block ()
  132.     eval-and-print(expr, num-debug-vars);
  133.       exception (problem :: <error>)
  134.     *format-function*(*debug-output*, "invocation failed:\n  ");
  135.     report-problem(problem);
  136.     *format-function*(*debug-output*, "\n");
  137.     *force-output-function*(*debug-output*);
  138.       end block;
  139.     end for;
  140.   exception (<abort>, init-arguments: list(description: "Blow off print"))
  141.     #f;
  142.   exception (<error>)
  143.     puts("Could not recover from earlier error.\n");
  144.   end block;
  145. end method debugger-print;
  146.  
  147.  
  148. define method debugger-report-condition (cond)
  149.   block ()
  150.     *format-function*(*debug-output*, "\n");
  151.     block ()
  152.       report-condition(cond, *debug-output*);
  153.     exception (problem :: <error>)
  154.       *format-function*(*debug-output*, "problem reporting condition:\n  ");
  155.       report-problem(problem);
  156.     end block;
  157.     *format-function*(*debug-output*, "\n\n");
  158.     *force-output-function*(*debug-output*);
  159.   exception <error>
  160.     puts("\nCould not recover from earlier errors.\n\n");
  161.   end block;
  162. end method debugger-report-condition;
  163.  
  164.  
  165. define method debugger-abort ()
  166.   block ()
  167.     block ()
  168.       signal(make(<abort>));
  169.     exception (problem :: <error>)
  170.       *format-function*(*debug-output*,
  171.             "problem signaling abort restart:\n  ");
  172.       report-problem(problem);
  173.       *format-function*(*debug-output*, "\n");
  174.       *force-output-function*(*debug-output*);
  175.     end block;
  176.   exception <error>
  177.     puts("Could not recover from earlier errors.\n");
  178.   end block;
  179. end method debugger-abort;
  180.  
  181.  
  182. define method debugger-describe-restarts (cond)
  183.   block ()
  184.     block ()
  185.       let index = 0;
  186.       for (h = current-handler() then h.handler-next, while h)
  187.     let type = h.handler-type;
  188.     if (instance?(type, <class>) & subtype?(type, <restart>))
  189.       block ()
  190.         *format-function*(*debug-output*, "%= [%=]: ", index, type);
  191.         report-condition(apply(make, type, h.handler-init-args),
  192.                  *debug-output*);
  193.       exception (problem :: <error>)
  194.         *format-function*(*debug-output*,
  195.                   "\nproblem describing restart:\n  ");
  196.         report-problem(problem);
  197.       end block;
  198.       *format-function*(*debug-output*, "\n");
  199.       index := index + 1;
  200.     end if;
  201.       end for;
  202.       if (zero?(index))
  203.     *format-function*(*debug-output*, "No active restarts.\n");
  204.       end if;
  205.     exception (problem :: <error>)
  206.       *format-function*(*debug-output*, "\nproblem describing restarts:\n  ");
  207.       report-problem(problem);
  208.       *format-function*(*debug-output*, "\n");
  209.     end block;
  210.     block ()
  211.       if (instance?(cond, <condition>) & return-allowed?(cond))
  212.     block ()
  213.       *format-function*(*debug-output*, "\nReturning is allowed");
  214.       let description = return-description(cond);
  215.       select (description by instance?)
  216.         singleton(#f) =>
  217.           #f;
  218.         <byte-string> =>
  219.           *format-function*(*debug-output*, ":\n  %s", description);
  220.         <restart> =>
  221.           *format-function*(*debug-output*, ":\n  ");
  222.           report-condition(description, *debug-output*);
  223.       end select;
  224.       *force-output-function*(*debug-output*);
  225.     exception (problem :: <error>)
  226.       *format-function*(*debug-output*,
  227.                 "\nproblem describing return convention:\n  ");
  228.       report-problem(problem);
  229.     end block;
  230.     *format-function*(*debug-output*, "\n");
  231.       end if;
  232.       *force-output-function*(*debug-output*);
  233.     exception (problem :: <error>)
  234.       *format-function*(*debug-output*,
  235.             "\nproblem checking on return contention:\n  ");
  236.       report-problem(problem);
  237.       *format-function*(*debug-output*, "\n");
  238.       *force-output-function*(*debug-output*);
  239.     end block;
  240.   exception <error>
  241.     puts("\nCould not recover from earlier errors.\n");
  242.   end block;
  243. end method debugger-describe-restarts;
  244.  
  245.  
  246. define method debugger-restart (cond, index)
  247.   block (return)
  248.     let count = 0;
  249.     for (h = current-handler() then h.handler-next, while h)
  250.       let type = h.handler-type;
  251.       let test = h.handler-test;
  252.       if (instance?(type, <class>) & subtype?(type, <restart>))
  253.     if (count == index)
  254.       block ()
  255.         let restart = apply(make, type, h.handler-init-args);
  256.         restart-query(restart);
  257.         unless (~test | test(h))
  258.           *format-function*(*debug-output*,
  259.                 "The restart handler refused to "
  260.                   "handle the restart.\n");
  261.           *force-output-function*(*debug-output*);
  262.           return(#f);
  263.         end unless;
  264.         local
  265.           method next-handler ()
  266.         *format-function*(*debug-output*,
  267.                   "The restart handler declined "
  268.                     "to handle the restart.\n");
  269.         *force-output-function*(*debug-output*);
  270.         return(#f);
  271.           end method next-handler;
  272.         let (#rest values) = h.handler-function(restart, next-handler);
  273.         if (instance?(cond, <condition>) & return-allowed?(cond))
  274.           return(#t, values);
  275.         else
  276.           *format-function*(*debug-output*,
  277.                 "The restart handler tried to return, but "
  278.                   "returning is not allowed\n");
  279.           *force-output-function*(*debug-output*);
  280.           return(#f);
  281.         end if;
  282.       exception (problem :: <error>)
  283.         *format-function*(*debug-output*,
  284.                   "Problem while attempting to restart:\n  ");
  285.         report-problem(problem);
  286.         *format-function*(*debug-output*, "\n");
  287.         *force-output-function*(*debug-output*);
  288.         return(#f);
  289.       end block;
  290.     else
  291.       count := count + 1;
  292.     end if;
  293.       end if;
  294.     end for;
  295.     if (zero?(count))
  296.       *format-function*(*debug-output*, "No active restarts.\n");
  297.     else
  298.       *format-function*(*debug-output*,
  299.             "Invalid restart number, should be less than %d\n",
  300.             count);
  301.     end if;
  302.     *force-output-function*(*debug-output*);
  303.     #f;
  304.   exception <error>
  305.     puts("Could not recover from earlier errors.\n");
  306.     #f;
  307.   end block;
  308. end method debugger-restart;
  309.       
  310.     
  311. define method debugger-return (cond)
  312.   block (return)
  313.     block ()
  314.       if (instance?(cond, <condition>) & return-allowed?(cond))
  315.     block ()
  316.       let (#rest values) = return-query(cond);
  317.       return(#t, values);
  318.     exception (problem :: <error>)
  319.       *format-function*(*debug-output*,
  320.                 "problem quering for values to return:\n  ");
  321.       report-problem(problem);
  322.       *format-function*(*debug-output*, "\n");
  323.       *force-output-function*(*debug-output*);
  324.       return(#f);
  325.     end block;
  326.       else
  327.     *format-function*(*debug-output*, "Returning is not allowed\n");
  328.     *force-output-function*(*debug-output*);
  329.     return(#f);
  330.       end if;
  331.     exception (problem :: <error>)
  332.       *format-function*(*debug-output*,
  333.             "problem checking to see if "
  334.               "returning is allowed:\n  ");
  335.       report-problem(problem);
  336.       *format-function*(*debug-output*, "\n");
  337.       *force-output-function*(*debug-output*);
  338.       return(#f);
  339.     end block;
  340.   exception <error>
  341.     puts("Could not recover from earlier errors.\n");
  342.     #f;
  343.   end block;
  344. end method debugger-return;
  345.  
  346.  
  347.  
  348. // Now that we have the dylan helper routines defined, enable the error system.
  349. //
  350. enable-error-system();
  351.